home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / LWP / Protocol / nntp.pm < prev    next >
Encoding:
Perl POD Document  |  2008-04-11  |  3.9 KB  |  151 lines
  1. package LWP::Protocol::nntp;
  2.  
  3. # Implementation of the Network News Transfer Protocol (RFC 977)
  4.  
  5. require LWP::Protocol;
  6. @ISA = qw(LWP::Protocol);
  7.  
  8. require LWP::Debug;
  9. require HTTP::Response;
  10. require HTTP::Status;
  11. require Net::NNTP;
  12.  
  13. use strict;
  14.  
  15.  
  16. sub request
  17. {
  18.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  19.  
  20.     LWP::Debug::trace('()');
  21.  
  22.     $size = 4096 unless $size;
  23.  
  24.     # Check for proxy
  25.     if (defined $proxy) {
  26.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  27.                    'You can not proxy through NNTP');
  28.     }
  29.  
  30.     # Check that the scheme is as expected
  31.     my $url = $request->url;
  32.     my $scheme = $url->scheme;
  33.     unless ($scheme eq 'news' || $scheme eq 'nntp') {
  34.     return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  35.                    "LWP::Protocol::nntp::request called for '$scheme'");
  36.     }
  37.  
  38.     # check for a valid method
  39.     my $method = $request->method;
  40.     unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
  41.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  42.                    'Library does not allow method ' .
  43.                    "$method for '$scheme:' URLs");
  44.     }
  45.  
  46.     # extract the identifier and check against posting to an article
  47.     my $groupart = $url->_group;
  48.     my $is_art = $groupart =~ /@/;
  49.  
  50.     if ($is_art && $method eq 'POST') {
  51.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  52.                    "Can't post to an article <$groupart>");
  53.     }
  54.  
  55.     my $nntp = Net::NNTP->new($url->host,
  56.                   #Port    => 18574,
  57.                   Timeout => $timeout,
  58.                   #Debug   => 1,
  59.                  );
  60.     die "Can't connect to nntp server" unless $nntp;
  61.  
  62.     # Check the initial welcome message from the NNTP server
  63.     if ($nntp->status != 2) {
  64.     return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE,
  65.                    $nntp->message);
  66.     }
  67.     my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  68.  
  69.     my $mess = $nntp->message;
  70.     LWP::Debug::debug($mess);
  71.  
  72.     # Try to extract server name from greeting message.
  73.     # Don't know if this works well for a large class of servers, but
  74.     # this works for our server.
  75.     $mess =~ s/\s+ready\b.*//;
  76.     $mess =~ s/^\S+\s+//;
  77.     $response->header(Server => $mess);
  78.  
  79.     # First we handle posting of articles
  80.     if ($method eq 'POST') {
  81.     $nntp->quit; $nntp = undef;
  82.     $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
  83.     $response->message("POST not implemented yet");
  84.     return $response;
  85.     }
  86.  
  87.     # The method must be "GET" or "HEAD" by now
  88.     if (!$is_art) {
  89.     if (!$nntp->group($groupart)) {
  90.         $response->code(&HTTP::Status::RC_NOT_FOUND);
  91.         $response->message($nntp->message);
  92.     }
  93.     $nntp->quit; $nntp = undef;
  94.     # HEAD: just check if the group exists
  95.     if ($method eq 'GET' && $response->is_success) {
  96.         $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
  97.         $response->message("GET newsgroup not implemented yet");
  98.     }
  99.     return $response;
  100.     }
  101.  
  102.     # Send command to server to retrieve an article (or just the headers)
  103.     my $get = $method eq 'HEAD' ? "head" : "article";
  104.     my $art = $nntp->$get("<$groupart>");
  105.     unless ($art) {
  106.     $nntp->quit; $nntp = undef;
  107.     $response->code(&HTTP::Status::RC_NOT_FOUND);
  108.     $response->message($nntp->message);
  109.     return $response;
  110.     }
  111.     LWP::Debug::debug($nntp->message);
  112.  
  113.     # Parse headers
  114.     my($key, $val);
  115.     local $_;
  116.     while ($_ = shift @$art) {
  117.     if (/^\s+$/) {
  118.         last;  # end of headers
  119.     }
  120.     elsif (/^(\S+):\s*(.*)/) {
  121.         $response->push_header($key, $val) if $key;
  122.         ($key, $val) = ($1, $2);
  123.     }
  124.     elsif (/^\s+(.*)/) {
  125.         next unless $key;
  126.         $val .= $1;
  127.     }
  128.     else {
  129.         unshift(@$art, $_);
  130.         last;
  131.     }
  132.     }
  133.     $response->push_header($key, $val) if $key;
  134.  
  135.     # Ensure that there is a Content-Type header
  136.     $response->header("Content-Type", "text/plain")
  137.     unless $response->header("Content-Type");
  138.  
  139.     # Collect the body
  140.     $response = $self->collect_once($arg, $response, join("", @$art))
  141.       if @$art;
  142.  
  143.     # Say goodbye to the server
  144.     $nntp->quit;
  145.     $nntp = undef;
  146.  
  147.     $response;
  148. }
  149.  
  150. 1;
  151.